HPAVC/HPAVC CD-ROM.iso/FUZZY.ZIP/AVL.B

Text File | 1986-11-30 | 16KB | 502 lines

-------------------------------------------------------------------------------
--                                                                           --
--  Library Unit:  AVL  --  Generic AVL tree package                         --
--                                                                           --
--  Author:  Bradley L. Richards                                             --
--                                                                           --
--     Version     Date     Notes . . .                                      --
--    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -    --
--       1.0    12 Mar 86   Initial Version (delete & update not done)       --
--       1.1    19 Aug 86   Added update and release procedures              --
--       1.2     7 Sep 86   Added delete procedure; cleaned up code          --
--    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -    --
--                                                                           --
--  Library units used:  none                                                --
--                                                                           --
--  Description:  This package provides generic functions for creating,      --
--      modifying, and accessing AVL trees.  AVL trees are binary trees      --
--      which never have more than one level of imbalance between any        --
--      two subtrees.  Balance is maintained automatically when the tree     --
--      is being built.                                                      --
--           The data to be maintained in the tree is never actually passed  --
--      to this package.  Rather, pointers to the data are passed in, via    --
--      type "node_ptr."  Also, comparison functions on the key fields of    --
--      the data must be provided.  The package requires a less-than and an  --
--      equality test.                                                       --
--                                                                           --
-------------------------------------------------------------------------------
package body avl is

  procedure add_node( tree : in out tree_ptr; data : in node_ptr;
                             duplicate : out boolean) is
      needs_balanced : boolean;
      pivot_parent, pivot, pivot_child, pivot_grandchild : tree_ptr := null;

      procedure insert_node( tree : in out tree_ptr; data : in node_ptr;
                 duplicate, needs_balanced : out boolean;
                 pivot_parent, pivot, pivot_child,
                 pivot_grandchild : out tree_ptr ) is
      found, pivot_found, placed : boolean := false;
      ptr_child, ptr_grandchild : tree_ptr := null;
      ptr : tree_ptr := tree;
    begin
      if tree = null then -- no nodes in tree
        tree := new tree_node'(same, null, null, null, data);
        duplicate := false;
        needs_balanced := false;
      else -- must search tree
        loop
          if equal(data, ptr.data) then
        found := true;
          elsif less_than(data, ptr.data) then
        if ptr.left_child = null then
          ptr.left_child := new tree_node'(same,null,null,ptr,data);
          ptr_child := ptr.left_child;
          placed := true;
        else
          ptr := ptr.left_child;
        end if;
          else
        if ptr.right_child = null then
          ptr.right_child := new tree_node'(same,null,null,ptr,data);
          ptr_child := ptr.right_child;
          placed := true;
        else
          ptr := ptr.right_child;
        end if;
          end if;
          exit when found or placed;
        end loop;
        if found then
          duplicate := true;
        else -- trace back through the tree adjusting balances
          duplicate := false;
          loop
        case ptr.balance is
          when left      => if ptr_child = ptr.left_child then
                      ptr.balance := tall_left;
                    else
                      ptr.balance := same;
                    end if;
                    pivot_found := true;
          when same      => if ptr_child = ptr.left_child then
                      ptr.balance := left;
                    else
                      ptr.balance := right;
                    end if;
                    ptr_grandchild := ptr_child;
                    ptr_child := ptr;
                    ptr := ptr.parent;
          when right     => if ptr_child = ptr.left_child then
                      ptr.balance := same;
                    else
                      ptr.balance := tall_right;
                    end if;
                    pivot_found := true;
          when others    => -- some sort of major tree construction
                    -- error has occurred
                    raise avl_error;
          end case;
        exit when pivot_found or (ptr = null);
          end loop;
          needs_balanced := false;
          if pivot_found then
        if (ptr.balance = tall_left) or (ptr.balance = tall_right) then
          needs_balanced := true;
          pivot_parent := ptr.parent;
          pivot := ptr;
          pivot_child := ptr_child;
          pivot_grandchild := ptr_grandchild;
        end if;
          end if;
        end if;
      end if;
    end insert_node;


    begin -- add node
      --
      --  insert_node places the node into the tree, adjusts all
      --  required balances, and determines whether or not the
      --  tree needs balanced.  If it does, pivot points to the
      --  pivot node for the rotation(s)
      --
      insert_node(tree, data, duplicate, needs_balanced, pivot_parent,
          pivot, pivot_child, pivot_grandchild);
      if needs_balanced then
    if needs_single_rotation(pivot_parent, pivot, pivot_child,
                              pivot_grandchild) then
      rotate_singly(pivot_parent, pivot, pivot_child);
    else
      rotate_doubly(pivot_parent, pivot, pivot_child, pivot_grandchild);
    end if;
    if pivot_parent = null then -- pivot points to new root node
      tree := pivot;
    end if;
      end if;
    end add_node;


  function copy_tree( original : tree_ptr ) return tree_ptr is
      root : tree_ptr;
    begin
      if original = null then
    return null;
      else
    root := new tree_node;
    root.balance := original.balance;
    root.data := original.data;
    root.left_child := copy_tree(original.left_child);
    root.right_child := copy_tree(original.right_child);
      end if;
    end copy_tree;


  --
  --  Delete_node -- This routine, when implemented, will remove the matching
  --                 node from the AVL structure and automatically rebalance
  --                 the tree.  It should also allow an option to deallocate
  --                 the data.
  --
  procedure delete_node( tree : in out tree_ptr; data : in node_ptr;
                        not_found : out boolean) is
      duplicate : boolean;
      new_tree, parent, ptr : tree_ptr;

      --
      --  Merge merges two trees together.  The right tree is assumed to be
      --  either the smaller tree (for efficiency) or perhaps an invalid
      --  AVL tree.
      --
      procedure merge( t1, t2 : tree_ptr; new_tree : out tree_ptr ) is
      tree : tree_ptr := t1; -- t1 is the working AVL tree
      ptr : tree_ptr := t2;
      parent : tree_ptr;

    begin
      if tree /= null then
        tree.parent := null;
      end if;
      if ptr /= null then
        ptr.parent := null;
      end if;
      while ptr /= null loop
        if ptr.left_child /= null then
          ptr := ptr.left_child;
        elsif ptr.right_child /= null then
          ptr := ptr.right_child;
        else -- both children null
          add_node(tree, ptr.data, duplicate);
          if duplicate then
            raise avl_error;
          end if;
          parent := ptr.parent;
          if parent /= null then
            if parent.left_child = ptr then
              free_AVL(parent.left_child);
            else
              free_AVL(parent.right_child);
            end if;
          else
        free_AVL(ptr);
          end if;
          ptr := parent;
        end if;
      end loop;
      new_tree := tree;
    end merge;


    begin -- delete_node
      if tree = null then
    not_found := true;
      else
    ptr := fetch_node(tree, data);
    if ptr = null then
      not_found := true;
    else
      if ptr.balance = right then -- list taller tree first
        merge(ptr.right_child, ptr.left_child, new_tree);
      else
        merge(ptr.left_child, ptr.right_child, new_tree);
      end if;
      parent := ptr.parent;
      if parent /= null then -- didn't delete the root node
        if parent.left_child = ptr then
          parent.left_child := null;
        else
          parent.right_child := null;
        end if;
        merge(new_tree, tree, new_tree);
      end if;
      free_AVL(ptr);
      tree := new_tree;
    end if;
      end if;
    end delete_node;


  --
  --  Fetch_node -- This function returns a pointer to the data associated
  --                with the AVL node which matches the input data key field.
  --
  function fetch_node( tree : tree_ptr; data : node_ptr) return node_ptr is
      node : tree_ptr;
    begin
      node := fetch_node(tree, data);
      if node = null then
    return null;
      else
    return node.data;
      end if;
    end fetch_node;

  function fetch_node( tree : tree_ptr; data : node_ptr) return tree_ptr is
      ptr : tree_ptr := tree;
    begin
      if tree = null then
    return null;
      else
    loop
      if equal(data, ptr.data) then
        return ptr;
      elsif less_than(data, ptr.data) then
        if ptr.left_child = null then
          return null;
        else
          ptr := ptr.left_child;
        end if;
      else
        if ptr.right_child = null then
          return null;
        else
          ptr := ptr.right_child;
        end if;
      end if;
    end loop;
      end if;
    end fetch_node;


  function init_tree return tree_ptr is
    begin
      return null;
    end init_tree;


function needs_single_rotation(p1, p2, p3, p4 : in tree_ptr) return boolean is
  begin
    if p4 /= null then
      if ( (p3.balance = left) and (p2.balance = tall_right) ) or
     ( (p3.balance = right) and (p2.balance = tall_left) ) then
    return false; -- requires double rotation
      else
    return true;
      end if;
    else -- we shouldn't have been called
      raise avl_error;
    end if;
  end needs_single_rotation;


--procedure print_tree( tree : tree_ptr ) is -- debug

    --procedure print_node( node : tree_ptr; indent : natural ) is

    --procedure space( num : natural ) is
      --begin
        --for i in 1..num loop
          --put(' ');
        --end loop;
      --end space;

      --begin
    --space(indent);
    --if node = null then
      --put_line("<null>");
    --else
      --put_data(node.data);
      --put("  ");
      --put(node.balance);
      --if (node.left_child /= null) and then
         --(node.left_child.parent /= node) then
        --put("  left child parent discrepancy");
      --end if;
      --if (node.right_child /= null) and then
         --(node.right_child.parent /= node) then
        --put("  right child parent discrepancy");
      --end if;
      --new_line;
      --print_node(node.left_child, indent+2);
      --print_node(node.right_child, indent+2);
    --end if;
      --end print_node;

  --begin
    --if (tree /= null) and then (tree.parent /= null) then
      --put_line("tree parent discrepancy");
    --end if;
    --print_node(tree, 0);
  --end print_tree;


  --
  --  Release -- This routine releases all nodes in an AVL tree.  It does
  --             not release the data associated with the nodes.  For cases
  --             where the AVL structure was just a temporary way of
  --             structuring the data this is fine, but eventually the
  --             release procedure should allow an option to release data
  --             associated with AVL nodes.  This will require another
  --             generic procedure parameter to the package.
  --
  procedure release( tree : in out tree_ptr ) is
    begin
      if tree /= null then
    if tree.left_child /= null then
      release( tree.left_child );
    end if;
    if tree.right_child /= null then
      release( tree.right_child );
    end if;
      free_AVL(tree);
      end if;
    end release;


procedure rotate_doubly(p1, p2, p3, p4 : in out tree_ptr) is
  begin
    if p2.balance = tall_left then
      p2.left_child := p4.right_child;
      if p4.right_child /= null then
    p4.right_child.parent := p2;
      end if;
      p3.right_child := p4.left_child;
      if p4.left_child /= null then
    p4.left_child.parent := p3;
      end if;
      p4.left_child := p3;
      p4.right_child := p2;
      case p4.balance is
    when left   => p2.balance := right;
                 p3.balance := same;
    when same   => p2.balance := same;
               p3.balance := same;
      when right  => p2.balance := same;
               p3.balance := left;
    when others => raise avl_error;
    end case;
    else
      p2.right_child := p4.left_child;
      if p4.left_child /= null then
    p4.left_child.parent := p2;
      end if;
      p3.left_child := p4.right_child;
      if p4.right_child /= null then
    p4.right_child.parent := p3;
      end if;
      p4.left_child := p2;
      p4.right_child := p3;
      case p4.balance is
    when left   => p3.balance := right;
               p2.balance := same;
    when same   => p3.balance := same;
               p2.balance := same;
    when right  => p3.balance := same;
               p2.balance := left;
    when others => raise avl_error;
    end case;
    end if;
    p4.parent := p1;
    p4.balance := same;
    p2.parent := p4;
    p3.parent := p4;
    if p1 = null then
      p2 := p4;                                -- we've changed the root
    elsif p1.left_child = p2 then
      p1.left_child := p4;
    else
      p1.right_child := p4;
    end if;
  end rotate_doubly;


procedure rotate_singly(p1, p2, p3 : in out tree_ptr) is
  begin
    if p2.balance = tall_left then
      p2.left_child := p3.right_child;
      if p3.right_child /= null then
    p3.right_child.parent := p2;
      end if;
      p3.right_child := p2;
      if p3.balance = left then
    p2.balance := same;
      else
    p2.balance := left;
      end if;
    else
      p2.right_child := p3.left_child;
      if p3.left_child /= null then
    p3.left_child.parent := p2;
      end if;
      p3.left_child := p2;
      if p3.balance = right then
    p2.balance := same;
      else
    p2.balance := right;
      end if;
    end if;
    p2.parent := p3;
    p3.balance := same;
    p3.parent := p1;
    if p1 = null then
      p2 := p3;                           -- we've changed the root
    elsif p1.left_child = p2 then
      p1.left_child := p3;
    else
      p1.right_child := p3;
    end if;
  end rotate_singly;


  --
  --  Update_node -- This routine locates the node whose key field matches
  --                 the data and replaces the node data witht the new data
  --                 included in this call.  If no matching node is found
  --                 not_found will be true.
  --
  --                 This routine should be modified to optionally release
  --                 the old data.
  --
  procedure update_node( tree : in tree_ptr; data : in node_ptr;
                        not_found : out boolean ) is
      ptr : tree_ptr := tree;
    begin
      if tree = null then
    not_found := true;
      else
    loop
      if equal(data, ptr.data) then
        not_found := false;
        ptr.data := data;
        exit;
      elsif less_than(data, ptr.data) then
        if ptr.left_child = null then
          not_found := true;
          exit;
        else
          ptr := ptr.left_child;
        end if;
      else
        if ptr.right_child = null then
          not_found := true;
          exit;
        else
          ptr := ptr.right_child;
        end if;
      end if;
    end loop;
      end if;
    end update_node;

end avl;